home *** CD-ROM | disk | FTP | other *** search
/ System Booster / System Booster.iso / Desktop Improver / IconTools / source / FloatIcon.f next >
Encoding:
FORTH Source  |  1996-09-27  |  3.7 KB  |  162 lines
  1. \ $VER: FloatIcon.f 1.05 (19 Jan 1992 23:07)(07 Jan 1992 21:19)
  2. \ Program to release several icons simultaneously so that WorkBench will
  3. \ handle their placement in a drawer window.
  4. \ Written in JForth Professional 2.0
  5. \
  6. \ (c) Copyright 1989, 1990, 1992 by Richard Mazzarisi.
  7. \  All rights reserved.
  8. \
  9. \ address:
  10. \    891 Post St. #207
  11. \    San Francisco, CA
  12. \    94109
  13. \
  14. \ email:
  15. \    rich@californium.cchem.berkeley.edu
  16. \    rmazz@hydrogen.cchem.berkeley.edu
  17. \
  18. \
  19. \ v. 1.00 10/9/89
  20. \ v. 1.01 2/3/90   fixed the path name for drawers, WB gives you the name
  21. \            with a '/' at the end which must be removed whereas
  22. \            Jazzbench does not
  23. \ v. 1.02 3/22/90  fixed bug in 'remove.final.slash' was 2DROP changed to DROP
  24. \      3/23/90  fixed problem similar to '/' with ':' on device icons
  25. \ v. 1.03 5/20/90  fixed the ability to find the font size and use this info
  26. \            in opening the window
  27. \ v. 1.04 1/1/92   fixed once and for all the finding of the font size
  28. \      1/7/92   put all icontools common stuff into icontools.f
  29. \      1/9/92   fixed typo in comment and error message
  30. \      1/13/92  moved the resource management routines to IconTools.f
  31. \ v. 1.05 1/19/92  recompiled with new IconTools.f (cf)
  32. \
  33. \ Instructions:
  34. \ 1 - Click on the icon for this program.
  35. \ 2 - Shift click on all icons to be floated.
  36. \
  37. \ (NOTE: The author assumes no responsibility for any damages
  38. \ resulting from the use of this program.)
  39.  
  40.  
  41. INCLUDE? TASK-ICONTOOLS ICONTOOLS.F
  42.  
  43.  
  44. ANEW task-floaticon
  45.  
  46. DECIMAL
  47.  
  48.  
  49. \ *** main window stuff ***
  50.  
  51. : open.ft-window      ( -- window/null )
  52.     getWBscreendata
  53.     it-newwindow NEWWINDOW.SETUP
  54.     20 16 set.vert-params
  55.     it-newwindow ..! nw_Height
  56.     it-newwindow ..! nw_TopEdge
  57.     20 52 set.horiz-params
  58.     it-newwindow ..! nw_Width
  59.     it-newwindow ..! nw_LeftEdge
  60.     0" FloatIcon  1.05" >ABS it-newwindow ..! nw_Title
  61.     CLOSEWINDOW it-newwindow ..! nw_IDCMPFlags
  62.     WINDOWCLOSE WINDOWDRAG | WINDOWDEPTH | WINDOWSIZING | ACTIVATE |
  63.         it-newwindow ..! nw_Flags
  64.     it-newwindow GR.OPENCURW
  65. ;
  66.  
  67.  
  68. \ *** support ***
  69.  
  70. : ft.greeting    ( -- )
  71.     " Release icons to be freely placed by Workbench." con.write.itl con.cr
  72.     " © Copyright by Richard Mazzarisi 1989, 1990, 1992" con.write.c3 con.cr
  73.     "          All rights reserved." con.write.c3 con.cr
  74.     "      Written in JForth Professional 2.0." con.write.c3 con.cr con.cr
  75. ;
  76.  
  77.  
  78. : prt.ft-instr    ( -- )
  79.     " Instructions:"  con.write con.cr
  80.     " 1 - Click on the icon for this program."  con.write con.cr
  81.     " 2 - Shift click on all the icons to be floated."  con.write con.cr
  82.     con.cr
  83.     " (NOTE: The author assumes no responsibility for any"
  84.     con.write con.cr
  85.     " damages resulting from the use of this program.)" con.write con.cr
  86. ;
  87.  
  88.  
  89. : float.it    ( -- )
  90.     PAD $it.get-icon
  91. [ clone-it @ ] .IF
  92.     SET-NO-POSITION
  93.     PAD $it.save-icon
  94. .ELSE
  95. \ don't really do it if we are testing things in the interpreter
  96.     it.abort-icon
  97. .THEN
  98. ;
  99.  
  100.  
  101. : float.one    { wbarg -- }
  102.     \ get file's path name
  103.     wbarg get.full-path IF
  104.         "   " con.write
  105.         PAD con.write con.cr
  106.         float.it
  107.     ELSE
  108.         " ERROR: Could not get path for icon:" con.write.itl con.cr
  109.         "   " con.write
  110.         wreq @ wbarg ..@ wa_Name >REL ConPutStr() con.cr
  111.     THEN
  112. ;
  113.  
  114.  
  115. : do.floats    { #args -- }
  116.         " Click closebox to abort."  con.write con.cr con.cr
  117.         " Floating..." con.write con.cr
  118.         \ get pointer to args
  119.     WBMESSAGE @ >REL ..@ sm_ArgList >REL
  120.     \ 2nd and on are the icons to be floated
  121.     #args 1+  1  DO
  122.         DUP  SizeOf() WBArg  I *  +
  123.         float.one
  124.         \ check for stop action
  125.         ?CLOSEBOX IF LEAVE THEN
  126.     LOOP
  127.     DROP
  128.     con.cr " Done.  " con.write.itl
  129. ;
  130.  
  131.  
  132. \ *** main ***
  133.  
  134. : floaticon   ( -- )
  135.     ' prt.ft-instr IS prt.it-instr
  136.     ' open.ft-window IS open.it-window
  137.     open.it-things
  138.     cursor.off
  139.     ft.greeting
  140.     check.WB
  141.     2 check.num.args IF
  142.         do.floats
  143.     THEN
  144.     close.it-things
  145. ;
  146.  
  147.  
  148. : ft
  149.     floaticon
  150. ;
  151.  
  152.  
  153. clone-it @ .IF
  154.  
  155. initclone
  156. clone ft
  157. save-image FloatIcon FloatIcon -icon
  158.  
  159. .THEN
  160.  
  161. CR CR ." Type 'ft' to run." CR CR
  162.